home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Mac Magazin/MacEasy 25
/
Mac Magazin and MacEasy Magazine CD - Issue 25.iso
/
Grafik & Text
/
Alpha
/
Tcl
/
Modes
/
fortranMode.tcl
< prev
next >
Wrap
Text File
|
1996-08-15
|
21KB
|
670 lines
#=============================================================================
# Fortran mode definition and support procs
#
# Features:
# 1. Keyword colorization (slightly customizable)
# 2. Fortran-sensitive shift right/left preserve columns 1-6
# 3. Auto-indentation
# 4. Line-breaking with Ctl-Opt-J (a la emacs)
# 5. Subroutine indexing
# 6. Cmd-double-click subroutine and include-file lookup
# 7. Customizable comment and continuation characters
#
#------------------------------------------------------------------------------
# Author: Tom Pollard <pollard@chem.columbia.edu>
#
# To Do: work around grep failure for Unix-format tag files
#
# 1/96 - FortMarkFile no longer marks F90 "end subroutine ..." statements
# more F90 keywords (will they never cease?)
# 1/96 - user-selectable comment and continuation characters
# complete F90 keyword set (Thomas Bewley <bewley@rayleigh.stanford.edu>)
# F90 functions and comparison operators optionally colorized ( " " )
# more complete set of C preprocessor commands colorized
# fixed case-sensitivity problem in line-indent routines
# 1/96 - minor FortDblClick bug fix
# 12/95 - more complete keyword set for F90 and HPF (from Tom Scavo)
# 12/95 - cpp keyword colorization (George Nurser <g.nurser@soc.soton.ac.uk>)
# cmd-dbl-click supports cpp #include now
# 11/95 - added FortBreakLine
# fixed case-sensitivity bug
# 10/95 - fixed Cmd-Dbl-Click handler to deal w/ new(?) tag file format and
# improve performance (fortFindSub)
# 9/95 - fixed getFortPrev bug with numbered lines
# - shiftLeft/Right revert to normal behavior on ill-formatted lines
# 8/95 - auto-indentation is finally speedy and robust
# 5/95 - added Cmd-Dbl-Click handler
# - added auto-indentation
# 12/94 - fixed funcExpr, FortMarkFile search expressions
# - changed comment character from 'C' to 'c' (should be case-insensitive!)
# - added 'include' keyword
# - added FortShiftRight and FortShiftLeft procs
#------------------------------------------------------------------------------
#================================================================================
if {$startingUp} {
addMode Fort dummyFort {*.f *.inc *.INC *.fcm *.for *.FOR *.f9 *.f90 *.hpf } {}
return
}
proc dummyFort {} {}
newModeVar Fort sortedIsDefault {0} 1
newModeVar Fort wordWrap {0} 1
newModeVar Fort funcExpr {^[^cC*!][ \t]*(subroutine|[ \ta-z*0-9]*function|entry).*$} 0
newModeVar Fort autoMark {0} 1
newModeVar Fort electricTab {1} 1
# newModeVar Fort prefixString {c} 0
newModeVar Fort continueChar {$} 0
newModeVar Fort commentChar {c} 0
newModeVar Fort colorFuncs {0} 1
newModeVar Fort colorOpers {0} 1
newModeVar Fort indentComment {0} 1
newModeVar Fort markTag {{}} 0
#=============================================================================
# Colorize Fortran keywords
#
proc fortColorKeywords {{color blue} {comment red} {specialChars black}} {
global FortmodeVars
set FortKeywords {
allocatable allocate assign backspace block call character close common
complex contains continue cycle data deallocate dimension do double else
elseif end enddo endfile endif entry equivalence exit external extrinsic
forall format function goto if implicit include inquire integer intent
interface intrinsic logical module namelist nullify open optional
parameter pause pointer precision print private program public pure read
real recursive return rewind save sequence stop subroutine target then
use where while write assignment case default elsewhere endfile go none
operator procedure select to type
}
if {$specialChars != "black"} {
regModeKeywords -e $FortmodeVars(commentChar) -c $comment -k $color Fort $FortKeywords -i {=} -i {*} -i {/} -i {+} -i {-} -i {,} -i {(} -i {)} -I $specialChars
} else {
regModeKeywords -e $FortmodeVars(commentChar) -c $comment -k $color Fort $FortKeywords
}
unset FortKeywords
}
#=============================================================================
# Colorize selected C preprocessor keywords
#
proc fortColorCPP {{color green}} {
set CPPKeywords {
#if #endif #include #else #define #undef #ifdef #ifndef
}
regModeKeywords -a -k $color Fort $CPPKeywords
unset CPPKeywords
}
#=========================================================================
# Colorize Fortran operators
#
proc fortColorOpers {{color green}} {
set FortOperators {
eq ne lt le gt ge not and or eqv neqv true false
}
regModeKeywords -a -k $color Fort $FortOperators
unset FortOperators
}
#=========================================================================
# Colorize Fortran function keywords
#
proc fortColorFuncs {{color green}} {
# Fortran bit functions
#
set BitKeywords {
bit_size btest iand ibclr ibits ibset ieor ior ishft ishftc mvbits not
}
regModeKeywords -a -k $color Fort $BitKeywords
unset BitKeywords
# Fortran intrinsic functions
#
set IntrinsicKeywords {
abs acos aimag asin atan atan2 conjg cos cosh dble dim dprod exp ichar
len lge lgt lle llt log log10 max min mod sign sin sinh sqrt tan tanh
iabs dabs cabs dacos dint dnint dasin datan datan2 dcos ccos dcosh idim
ddim dexp cexp ifix idint alog ddlog clog alog10 dlog10 max0 amax0 max1
amax1 dmax1 min0 amin0 min1 amin1 dmin1 amod dmod idnint float sngl
isign dsign dsin csin dsinh dsqrt csqrt dtan dtanh aint anint char cmplx
index int nint achar adjustl adjustr all allocated any associated
bit_size btest ceiling count cshift date_and_time digits dot_product
eoshift epsilon exponent floor fraction huge iachar iand ibclr ibits
ibset ieor ior ishft ishftc kind lbound len_trim logical matmul
maxexponent maxloc maxval merge minexponent minloc minval modulo mvbits
nearest not pack precision present product radix random_number
random_seed range repeat reshape rrspacing scale scan selected_int_kind
selected_real_kind set_exponent shape size spacing spread sum
system_clock tiny transfer transpose trim ubound unpack verify
}
regModeKeywords -a -k $color Fort $IntrinsicKeywords
unset IntrinsicKeywords
}
fortColorKeywords blue red magenta
fortColorCPP green
#=============================================================================
# Special Fortran keybindings
#
bind '\[' <c> FortShiftLeft Fort
bind '\[' <co> FortShiftLeftSpace Fort
bind '\]' <c> FortShiftRight Fort
bind '\]' <co> FortShiftRightSpace Fort
bind '\t' doATab Fort
bind '\t' <o> {doATab 1} Fort
bind '\t' <z> {doATab 1} Fort
bind 'j' <zo> FortBreakLine Fort
trace variable FortmodeVars(commentChar) w shadowFort
trace variable FortmodeVars(colorFuncs) w shadowFort
trace variable FortmodeVars(colorOpers) w shadowFort
#=============================================================================
# Update colorization when Fortran mode variables are changed
#
proc shadowFort {name1 name2 op} {
global HOME FortmodeVars
if {$name1 == "FortmodeVars" && $op == "w"} {
switch $name2 {
"colorFuncs" {
if {$FortmodeVars(colorFuncs)} {
fortColorFuncs green
} else {
fortColorFuncs black
}
}
"colorOpers" {
if {$FortmodeVars(colorOpers)} {
fortColorOpers green
} else {
fortColorOpers black
}
}
"commentChar" {
fortColorKeywords blue red black
}
default {
return
}
}
}
}
#=============================================================================
#
proc FortMarkFile {} {
global FortmodeVars
set tag [quoteExpr2 $FortmodeVars(markTag)]
set pat0 {^.*(subroutine|.*function|entry|program).*$}
set pat1 {^[^cC*!]([ \ta-z*0-9]*)(subroutine|.*function|entry|program)[ \t]+([a-z0-9_]+)}
set end [maxPos]
set pos 0
while {![catch {search -s -f 1 -r 1 -m 0 -i 1 $pat1 $pos} mtch]} {
regexp -nocase $pat1 [eval getText $mtch] allofit valtyp subtyp name
set start [lineStart [lindex $mtch 0]]
set next [nextLineStart $start]
set pos $next
if {! [regexp -nocase "end" $valtyp mtch]} {
set inds([lineStart $start]) $name
}
}
set pat2 "^(c+${tag})\[ \t\]*(\[^\n\r\]*\[^ \t\])\[^ \t\]*\$"
set pos 0
while {![catch {search -s -f 1 -r 1 -m 0 -i 1 $pat2 $pos} mtch]} {
regexp -nocase $pat2 [eval getText $mtch] allofit cc comment
regsub -all {[\/\(\)]} $comment {} comment
set start [lindex $mtch 0]
set end [nextLineStart $start]
set pos $end
set inds([lineStart $start]) $comment
}
if {[info exists inds]} {
foreach f [lsort -integer [array names inds]] {
set next [nextLineStart $f ]
setNamedMark $inds($f) $f $f $f
}
}
}
#================================================================================
# Block shift left and right for Fortran mode (preserves cols 1-6)
#================================================================================
proc FortShiftLeft {} {
global shiftChar
doFortShiftLeft "\t"
}
proc FortShiftLeftSpace {} {
global shiftChar
doFortShiftLeft " "
}
proc doFortShiftLeft {shiftChar} {
set start [lineStart [getPos]]
set end [nextLineStart [expr [selEnd] - 1]]
if {$start >= $end} {set end [nextLineStart $start]}
set text [split [getText $start [expr $end - 1]] "\r"]
set textout ""
set pat {^([cC]|[ 0-9][ 0-9][ 0-9][ 0-9][ 0-9].| *[0-9]*\t)(.*)$}
foreach line $text {
if {[regexp $pat $line mtch pref body]} {
if {[string index $body 0] == $shiftChar} {
lappend textout $pref[string range $body 1 end]
} else {
lappend textout $line
}
} elseif {[string index $line 0] == $shiftChar} {
lappend textout [string range $line 1 end]
} else {
lappend textout $line
}
}
set text [join $textout "\r"]
replaceText $start [expr $end - 1] $text
select $start [expr 1 + $start + [string length $text]]
}
proc FortShiftRight {} {
global shiftChar
doFortShiftRight "\t"
}
proc FortShiftRightSpace {} {
global shiftChar
doFortShiftRight " "
}
proc doFortShiftRight {shiftChar} {
set start [lineStart [getPos]]
set end [nextLineStart [expr [selEnd] - 1]]
if {$start >= $end} {set end [nextLineStart $start]}
set text [split [getText $start [expr $end - 1]] "\r"]
set textout ""
set pat {^([cC]|[ 0-9][ 0-9][ 0-9][ 0-9][ 0-9].| *[0-9]*\t)(.*)$}
foreach line $text {
if {[regexp $pat $line mtch pref body]} {
lappend textout $pref$shiftChar$body
} else {
lappend textout $shiftChar$line
}
}
set text [join $textout "\r"]
replaceText $start [expr $end - 1] $text
select $start [expr 1 + $start + [string length $text]]
}
proc FortBreakLine {} {
global FortmodeVars
set pos [getPos]
set line [getText [lineStart $pos] [expr [nextLineStart $pos]-1]]
if {[regexp {^[cC*!]} $line char]} {
insertText "\n$char "
} else {
set char $FortmodeVars(continueChar)
insertText "\n $char"
}
FortindentLine
}
#=============================================================================
# Cmd-double-clicking opens include files, jumps to subroutine definitions,
# and follows tags.
#
proc FortDblClick {from to} {
global tagFile
set pat1 {^[^cC*!][ \ta-z*0-9]*(subroutine|.*function|entry)[ \t]+}
set incPat {^[^cC*!][ \t]*include[ \t]*['"]([^'"]+)['"]}
# First check whether an 'include' was clicked
set line [getText [lineStart $from] [expr [nextLineStart $to] - 1]]
if {[regexp -nocase $incPat $line allofit fname]} {
set path [absolutePath $fname]
if {[catch {openFileQuietly $path}]} {
message "include file \'$fname\' not found in source folder"
}
return
}
select $from $to
set text [getSelect]
# First check current file for subroutine definition,...
if {![catch {fortFindSub $text} mtch]} {
regexp -nocase $pat1 [eval getText $mtch] allofit subtyp name
pushMark
display [lindex $mtch 0]
# eval select $mtch
message "press <Ctl .> to return to original cursor position"
# ...then check tags file.
} else {
message "Searching tags file..."
set lines [grep "^$text'" $tagFile]
if {[regexp {'(.*)'} $lines dummy fname]} {
pushMark
if {[string match "*$fname*" [winNames -f]]} {
bringToFront $fname
} else {
edit $fname
}
set inds [fortFindSub $text]
# set inds [search -s -f 1 -r 1 -i 1 "$pat1$text" 0]
display [lindex $inds 0]
# eval select $inds
message "press <Ctl .> to return to original cursor position"
}
}
}
# Speedy search for a Fortran subroutine. Performance is dramatically
# improved by scanning for the name alone first, rather than running
# complicated regexp search on the entire file.
#
proc fortFindSub {name} {
set pat1 {^[^cC*!][ \ta-z*0-9]*(subroutine|.*function|entry)[ \t]+}
set pos 0
while {![catch {search -s -f 1 -r 0 -m 0 -i 1 $name $pos} mtch]} {
set beg [lineStart [lindex $mtch 0]]
set end [expr [nextLineStart [lindex $mtch 1]] -1]
set line [getText $beg $end]
if {[regexp -nocase $pat1$name $line allofit subtyp name]} {
return $mtch
} else {
set pos [lindex $mtch 1]
}
}
error "Subroutine \"$name\" not found"
}
#=============================================================================
# Fortan auto-indentation
#
# Logic:
# 0. Identify previous line
# a) ignore comments and continuation lines
# b) if current line is a CONTINUE that matches a DO, use the
# first corresponding DO as the previous line
#
# 1. Find leading whitespace for previous line
#
# 2. Increase whitespace if previous line starts a block, i.e.,
# a) DO loop
# b) IF ... THEN
# c) ELSE
#
# 3. Decrease whitespace if current line ends a block, i.e.,
# a) ELSE || ENDIF || END IF || ENDDO || END DO
# b) <linenum> CONTINUE matching a preceding DO
#
# or if previous line ends a DO loop on an executable statement, i.e.,
# c) <linenum> (not CONTINUE) matching a preceding DO
#
####################################################################################
# Fortan auto-indentation
#
proc FortindentLine {} {
set bol [lineStart [getPos]]
set eol [expr [nextLineStart $bol] - 1]
Fortindent $bol $eol
}
proc FortindentRegion {} {
Fortindent [getPos] [selEnd]
}
####################################################################################
# Fortan auto-indentation of a specified region
#
proc Fortindent {pos0 pos1} {
global fortDooz fortPrevLine fortTop msg
global FortmodeVars
set tag [quoteExpr2 $FortmodeVars(markTag)]
set doComment $FortmodeVars(indentComment)
# Define regexps
set subPat {^[^cC*!][ \ta-z*0-9]*(subroutine|.*function|entry|program)[ \t]+([a-z0-9_]+)}
set bolPat {^[^cC*!\n\r][ \t]*[^ \t\n\r][^\r\n]*$}
set mtPat {^[ \t]*$}
set tab " "
set contPat {^ ([^ \t\n\r])[^\r\n]*$}
set lnumPat {^([ \t]*)([0-9]*)([ \t]*)(.*)$}
set comPat "^(\[cC*!\]+(${tag})?)(\[ \t\]*)(.*)\$"
set doPat {^[^cC*!\n\r][ \t]*do[ \t]+}
set tailPat {[^\r\n]*$}
set bobPat {^(if[^\n\r]*then|else|do)}
set eobPat {^(end[ \t]*if|end[ \t]*do|else)}
set enddoPat {^(end[ \t]*do|continue)}
# set fortTop [fortSubTop $pos0]
set fortTop -1
catch {unset fortDooz}
set fortPrevLine ""
# Loop over region line by line
set from [lindex [posToRowCol $pos0] 0]
set to [lindex [posToRowCol $pos1] 0]
while {$from <= $to} {
set msg "Indenting line $from"
message $msg
set bol [lineStart [rowColToPos $from 0]]
set eol [expr [nextLineStart $bol] - 1]
set thisLine [getText $bol $eol]
goto $bol
# Check whether we're entering a new routine
#
if {[regexp $subPat $thisLine allofit subType subName]} {
# alertnote "entering subr: \/$subName\/"
set fortTop $bol
catch {unset fortDooz}
}
# Is the current line a comment line...
#
if {[regexp $comPat $thisLine allofit cc tag pre body]} {
if {$FortmodeVars(indentComment) > 0} {
set body [string trimright $body]
# alertnote "comment line: \/$pre\/$body\/"
set lwhite "$cc "
replaceText $bol $eol $lwhite$body
}
# ... or a line of code (possibly empty)?
#
} elseif {[regexp $lnumPat $thisLine allofit pre lnum post body]} {
set body [string trimright $body]
# alertnote "line: \/$pre\/$lnum\/$post\/$body\/"
# is it a continuation line?
#
if {(![regexp {\t} $pre]) && ([string length $pre] == 5)} {
set cont [string index $lnum$post$body 0]
set body [string trimleft [string range $lnum$post$body 1 end]]
} else {
set cont {}
}
# alertnote "cont: \/$cont\/"
# get whitespace for preceding line
set enddo [getFortPrev $bol $lnum]
set lwhite [getFortLwhite $bol]
# if this line ends a block, decrease the whitespace
if {[regexp $eobPat $body] || ($enddo && [regexp -nocase $enddoPat $body])} {
set lwlen [expr [string length $lwhite] - 4]
set lwhite [string range $lwhite 0 $lwlen]
}
if {[string length $lnum]} {
if {[string index $lwhite 0] != $tab} {
set lwhite [string range $lwhite [expr [string length $lnum] +1] end]
}
set lnum " $lnum"
}
# alertnote "lwhite: \/$lwhite\/ len: [string length $lwhite]"
# message "$msg : replacing text "
if {[string length $cont]} {
replaceText $bol $eol " $cont$lwhite$body"
} else {
replaceText $bol $eol $lnum$lwhite$body
if {[string length $body] > 0} {
set fortPrevLine $lnum$lwhite$body
}
}
} else {
# message "$msg : Couldn't parse line "
}
# message "$msg : Done "
incr from
}
}
proc getFortLwhite {bol} {
global fortDooz fortPrevLine fortTop msg
# Define regexps
set tab " "
set lnumPat {^([ \t]*)([0-9]*)([ \t]*)(.*)$}
set doPat {^[^cC*!\n\r][ \t]*do[ \t]+}
set bobPat {^(if[^\n\r]*then|else|do)}
set enddoPat {^(end[ \t]*do|continue)}
if {[regexp $lnumPat $fortPrevLine allofit pre0 lnum0 post0 body0]} {
# alertnote "prevLine: \/$pre0\/$lnum0\/$post0\/$body0\/"
if {[string length $lnum0]} {
if {[string index $post0 0] == $tab} {
set lwhite $post0
} else {
regsub -all {[0-9]} $pre0$lnum0$post0 { } lwhite
}
} else {
set lwhite $pre0
}
# alertnote "lwhite: \/$lwhite\/ len: [string length $lwhite]"
# message "$msg : got lwhite (initial)"
# if there's a line number and it's not a CONTINUE or ENDDO,
# then check for a matching DO statement and adjust
# indentation if found
#
if {[string length $lnum0] && ![regexp -nocase $enddoPat $body0]} {
if {[getFortPrev [lineStart [expr $bol - 1]] $lnum0]} {
set lwlen [expr [string length $lwhite] - 4]
set lwhite [string range $lwhite 0 $lwlen]
}
}
# If the preceeding line begins a block (IF-THEN, DO, or ELSE),
# then increase the whitespace
#
if {[regexp -nocase $bobPat $body0]} {
set lwhite "$lwhite "
if {[regexp -nocase "$doPat\(\[0-9\]+\)" $body0 mtch donum]} {
set eol [expr [nextLineStart $bol] - 1]
set fortDooz($donum) [getText $bol $eol]
}
}
# message "$msg : got lwhite (final) "
}
return "$lwhite"
}
proc getFortPrev {bol lnum} {
global fortDooz fortPrevLine fortTop msg
# Define regexps
set doPat {^[^cC*!\n\r][ \t]*do[ \t]+}
set bolPat {^[^cC*!\n\r][ \t]*[^ \t\n\r][^\r\n]*$}
set contPat {^ ([^ \t\n\r])[^\r\n]*$}
# if there's a line number, check for a matching DO statement ...
if {[string length $lnum]} {
if {[lsearch [array names fortDooz] $lnum] >= 0} {
set fortPrevLine $fortDooz($lnum)
return 1
} else {
if {$fortTop < 0} {
set fortTop [fortSubTop $bol]
}
if {![catch {search -s -f 0 -r 1 -i 1 -l $fortTop $doPat$lnum [expr $bol -1]} dolst]} {
set fortPrevLine [eval getText $dolst]
set fortDooz($lnum) $fortPrevLine
# alertnote "doLine0: \/$fortPrevLine\/"
return 1
}
}
}
# ... otherwise find the first preceding non-comment, non-continuation line
if {[string length $fortPrevLine] == 0} {
if {[catch {
set lst [search -s -f 0 -r 1 -i 1 -s $bolPat [expr $bol-1]]
set fortPrevLine [eval getText $lst]
while {[regexp -nocase $contPat $fortPrevLine]} {
set lst [search -s -f 0 -r 1 -i 1 $bolPat [expr [lindex $lst 0] - 1]]
set fortPrevLine [eval getText $lst]
}
}]} {
# if search fails, we're at the top of a file, so reset indentation
set fortPrevLine " continue"
}
}
# alertnote "prevLine: \/$fortPrevLine\/"
# message "$msg : got prevLine"
return 0
}
# Find the beginning of the current subroutine
#
proc fortSubTop {{pos 0}} {
if {$pos == 0} {
set pos [lineStart [getPos]]
}
set subPat {^[^cC*!][ \ta-z*0-9]*(subroutine|.*function|entry|program)[ \t]+([a-z0-9_]+)}
if {![catch {search -s -f 0 -r 1 -m 0 -i 1 $subPat $pos} sublst]} {
# set subLine [eval getText $sublst]
# alertnote "subLine: \/$subLine\/"
return [lindex $sublst 0]
} else {
return 0
}
}